home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 090 / byte0387.arc / LISPTEST.DOC < prev    next >
Lisp/Scheme  |  1980-01-01  |  9KB  |  441 lines
  1.  
  2. ;; BYTE TI Scheme Benchmark Source     5-20-86 WGW
  3.  
  4.  
  5. ;; Time Test
  6.  
  7. (define (time-function function)
  8.         (gc)                            ;; make sure system is consistent
  9.         (let ((start-time (runtime)))
  10.              (function)
  11.              (/ (- (runtime) start-time) 100.0)
  12.         )
  13. )
  14.  
  15.  
  16. (define (time-test function)
  17.         (gc)                            ;; make sure system is consistent
  18.         (let ((start-time (runtime)))
  19.              (loop-test function 5000)
  20.              (/ (- (runtime) start-time) 100.0)
  21.         )
  22. )
  23.  
  24.  
  25. ;; Loop test to get function time into timable range
  26.  
  27. (define (loop-test function limit)
  28.         (do ((i 1 (1+ i)))
  29.             ((>=? i limit))
  30.             (function)
  31.         )
  32. )
  33.  
  34.  
  35. ;; Dummy function to test LOOP-TEST
  36.  
  37. (define (dummy))
  38.  
  39.  
  40. ;; List construction test
  41.  
  42. (define cons-var nil)
  43.  
  44. (define (cons-test) (cons cons-var cons-var))
  45.  
  46.  
  47. ;; Integer addition test
  48.  
  49. (define add-a 1)
  50. (define add-b 2)
  51.  
  52. (define (add-test) (+ add-a add-b))
  53.  
  54.  
  55.  
  56. ;; Integer multiplication test
  57.  
  58. (define mult-a 1)
  59. (define mult-b 2)
  60.  
  61. (define (mult-test) (* mult-a mult-b))
  62.  
  63.  
  64. ;; Floating point addition test
  65.  
  66. (define fadd-a 1.2)
  67. (define fadd-b 234324.3)
  68.  
  69. (define (fadd-test) (+ fadd-a fadd-b))
  70.  
  71.  
  72. ;; Floating point multiplication test
  73.  
  74. (define fmult-a 1.2)
  75. (define fmult-b 234324.3)
  76.  
  77. (define (fmult-test) (* fmult-a fmult-b))
  78.  
  79.  
  80. ;; Assignment Test   (Load from variable and set global variable)
  81.  
  82. (define assign-a '(1 2 3))
  83.  
  84. (define (assign-test) (set! assign-a assign-a))
  85.  
  86.  
  87.  
  88. ;; Local Assignment Test
  89.  
  90.  
  91. (define (local-assign) (let ((x '())) (set! x '(1 2 3))))
  92.  
  93.  
  94. ;; List Indexing Test
  95.  
  96. (define (build-list length)
  97.         (if (zero? length)
  98.             '()
  99.             (cons length (build-list (sub1 length)))
  100.         )
  101. )
  102.  
  103.  
  104. (define list-a)
  105. (set! list-a (build-list 128))
  106.  
  107.  
  108. (define (list-index) (list-ref list-a 120))
  109.  
  110.  
  111.  
  112. ;; Vector Index Test
  113.  
  114. (define vect-a)
  115. (set! vect-a (make-vector 128 1))
  116.  
  117. (define (vector-index) (vector-ref vect-a 120))
  118.  
  119.  
  120. ;; String Index Test
  121.  
  122. (define string-a)
  123. (set! string-a (make-string 128 #\X ))
  124.  
  125. (define (string-index) (string-ref string-a 120))
  126.  
  127.  
  128.  
  129. ;; The good old Prime Number Sieve Test (Test on only 1 iteration)
  130.  
  131. (define (sieve)
  132.         (letrec ((count 0)        ;; number of primes found
  133.                  (size  7000)        ;; size of sieve array
  134.                  (flags (make-vector (add1 size) 0))
  135.                 )
  136.  
  137.                 (do ((i 0 (add1 i)))    ;; scan array from start
  138.                     ((> i size) count)    ;; to finish and return primes found
  139.                     (if (zero? (vector-ref flags i))
  140.                        (let ((prime (+ i i 3)))
  141.  
  142.                             (do ((k (+ i prime) (+ k prime)))
  143.                                 ((> k size) (set! count (add1 count)))
  144.                                 (vector-set! flags k 1)
  145.                             )        ;; reset non-prime flags
  146.                        )
  147.                     )
  148.                 )
  149.         )
  150. )
  151.  
  152.  
  153. ;; BYTE Calculation Test (Time only 1 iteration, looping is done internally)
  154.  
  155. (define (calc)
  156.         (do ((a 2.71828)        ;; setup parameters
  157.              (b 3.14159)
  158.              (c 1.0)
  159.              (i 1 (add1 i))
  160.             )
  161.  
  162.             ((=? i 5000) (- c 1))    ;; exit when end of test with error
  163.  
  164.             (set! c (* c a))        ;; perform calculations
  165.             (set! c (* c b))
  166.  
  167.             (set! c (/ c a))
  168.             (set! c (/ c b))
  169.         )
  170. )
  171.  
  172.  
  173. ;; End of BYTE TI Scheme Benchmark Source
  174.  
  175.  
  176.  
  177. "BYSO Lisp Benchmark    1-4-86  WGW"
  178.  
  179. "Test Loop"
  180.  
  181. (defun loop-test (fn limit)
  182.   (do (( i 1 ( + i 1 )))
  183.       ((= i limit))
  184.       (fn) ) )
  185.  
  186. (defun dummy ())
  187.  
  188.  
  189.  
  190. "CONS Test"
  191.  
  192. (setq cons-a nil)
  193.  
  194. (defun cons-test () (cons cons-a cons-a))
  195.  
  196.  
  197. "Integer Addition Test"
  198.  
  199. (setq add-a 1  add-b 2)
  200.  
  201. (defun add-test () (+ add-a add-b))
  202.  
  203.  
  204. "Integer Multiplication Test"
  205.  
  206. (setq multiply-a 1   multiply-b 2)
  207.  
  208. (defun multiply-test () (* multiply-a multiply-b))
  209.  
  210.  
  211. "Assignment Test"
  212.  
  213. (setq assign-a '(1 2 3))
  214.  
  215. (defun assign-test () (setq assign-a assign-a))
  216.  
  217.  
  218. "List Indexing Test"
  219.  
  220. (setq list-index-list '())
  221.  
  222. (do ((i 1 (+ i 1)))
  223.     ((= i 128))
  224.     (setq list-index-list (cons i list-index-list)) )
  225.  
  226. (defun list-index () (nth 120 list-index-list))
  227.  
  228.  
  229. "Vector Index Test"
  230.  
  231. (setq vector-test-array (array 'sexpr 128))
  232.  
  233. (defun vector-index () (aref vector-test-array 120))
  234.  
  235.  
  236. "String Index Test"
  237.  
  238. (setq string-test-array (array 'char 128))
  239.  
  240. (defun string-index () (aref string-test-array 120))
  241.  
  242.  
  243. "Write test creates a new file and writes 64 kbytes to it."
  244.  
  245. ( defun write-test ()
  246.           ( do-write-test ( open 'b:test )
  247.                           512
  248.                           ( array 'char 128 )
  249.           )
  250. )
  251.  
  252.  
  253. ( defun do-write-test ( file records buffer )
  254.           ( do ()
  255.                (( zerop ( setq records ( - records 1 ))) ( close file ))
  256.                ( princ buffer file )
  257.           )
  258. )
  259.  
  260. ; Waltz Lisp Benchmark         1-4-86 WGW
  261. ;
  262. ; Test Loop
  263.  
  264. (def loop-test (lambda (fn limit)
  265.                   (do ((i 1 ( + i 1 )))
  266.                       ((equal i limit))
  267.                       (fn) ) ))
  268.  
  269. (def dummy (lambda ()))
  270.  
  271.  
  272.  
  273. ; CONS Test
  274.  
  275. (setq cons-a nil)
  276.  
  277. (def cons-test (lambda () (cons cons-a cons-a)))
  278.  
  279.  
  280. ; Integer Addition Test
  281.  
  282. (setq add-a 1)
  283. (setq add-b 2)
  284.  
  285. (def add-test (lambda () (+ add-a add-b)))
  286.  
  287.  
  288. ; Integer Multiplication Test
  289.  
  290. (setq multiply-a 1)
  291. (setq multiply-b 2)
  292.  
  293. (def multiply-test (lambda () (* multiply-a multiply-b)))
  294.  
  295.  
  296. ; Assignment Test
  297.  
  298. (setq assign-a '(1 2 3))
  299.  
  300. (def assign-test (lambda () (setq assign-a assign-a)))
  301.  
  302.  
  303. ; List Indexing Test
  304.  
  305. (setq list-index-list '())
  306.  
  307. (do ((i 0 (+ i 1)))
  308.     ((equal i 128))
  309.     (setq list-index-list (cons i list-index-list)) )
  310.  
  311. (def list-index (lambda () (nth 120 list-index-list)))
  312.  
  313.  
  314. ; Vector Index Test  (Arrays Not Supported)
  315.  
  316.  
  317. ; String Index Test
  318.  
  319. (setq string-test-array "" )
  320.  
  321. (do ((i 0 (+ i 1)))
  322.     ((equal i 128))
  323.     (setq string-test-array (cat "1" string-test-array)) )
  324.  
  325. (def string-index (lambda () (substring string-test-array 120 120)))
  326.  
  327.  
  328. ; Write test creates a new file and writes 64 kbytes to it.
  329.  
  330. (def write-test (lambda ()
  331.                     ( do-write-test ( outfile "b:test" )
  332.                                     512
  333.                                     string-test-array ) ))
  334.  
  335.  
  336. (def do-write-test (lambda (file records buffer)
  337.           ( do ()
  338.                (( zerop ( setq records ( - records 1 ))) ( close file ))
  339.                ( princ buffer file ) ) ))
  340.  
  341.  
  342.  
  343. ;; Golden Common Lisp Benchmark    1-4-86  WGW
  344.  
  345. ;; Test Loop
  346.  
  347. (defun loop-test (fn limit)
  348.   (do (( i 1 ( + i 1 )))
  349.       ((= i limit))
  350.       (apply fn nil) ) )
  351.  
  352. (defun dummy () )
  353.  
  354.  
  355.  
  356. ;; CONS Test
  357.  
  358. (setq cons-a nil)
  359.  
  360. (defun cons-test () (cons cons-a cons-a))
  361.  
  362.  
  363. ;; Integer Addition Test
  364.  
  365. (setq add-a 1  add-b 2)
  366.  
  367. (defun add-test () (+ add-a add-b))
  368.  
  369.  
  370. ;; Integer Multiplication Test
  371.  
  372. (setq multiply-a 1   multiply-b 2)
  373.  
  374. (defun multiply-test () (* multiply-a multiply-b))
  375.  
  376.  
  377. ;; Floating Point Addition Test
  378.  
  379. (setq fp-add-a 1.2  fp-add-b 234324.3)
  380.  
  381. (defun fp-add-test () (+ fp-add-a fp-add-b))
  382.  
  383.  
  384. ;; Floating Point Multiplication Test
  385.  
  386. (setq fp-multiply-a 1.2   fp-multiply-b 234324.3)
  387.  
  388. (defun fp-multiply-test () (* fp-multiply-a fp-multiply-b))
  389.  
  390.  
  391. ;; Assignment Test
  392.  
  393. (setq assign-a '(1 2 3))
  394.  
  395. (defun assign-test () (setq assign-a assign-a))
  396.  
  397.  
  398. ;; List Indexing Test
  399.  
  400. (setq list-index-list '())
  401.  
  402. (do ((i 1 (+ i 1)))
  403.     ((= i 128))
  404.     (setq list-index-list (cons i list-index-list)) )
  405.  
  406. (defun list-index () (nth 120 list-index-list))
  407.  
  408.  
  409. ;; Vector Index Test
  410.  
  411. (setq vector-test-array (make-array 128 :initial-element nil))
  412.  
  413. (defun vector-index () (aref vector-test-array 120))
  414.  
  415.  
  416. ;; String Index Test
  417.  
  418. (setq string-test-array
  419.   (make-array 128 :element-type 'string-char :initial-element 32))
  420.  
  421. (defun string-index () (aref string-test-array 120))
  422.  
  423.  
  424. "Write test creates a new file and writes 64 kbytes to it."
  425.  
  426. (defun write-test ()
  427.          (do-write-test (open "b:test" :direction ':output)
  428.                         512
  429.                         (make-array 128 :element-type 'string-char)
  430.          )
  431. )
  432.  
  433.  
  434. ( defun do-write-test ( file records buffer )
  435.           ( do ()
  436.                (( zerop ( setq records ( - records 1 ))) ( close file ))
  437.                ( princ buffer file )
  438.           )
  439. )
  440.  
  441.